home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0187.ZIP / KISMET.PAS < prev    next >
Pascal/Delphi Source File  |  1985-01-20  |  11KB  |  507 lines
  1. (*
  2.  *  kismet game
  3.  *)
  4.  
  5. program kismet (input, output);
  6.  
  7. const
  8.    maxplayers   = 4;           (* maximum number of players *)
  9.    scores       = 15;          (* 15 ways to make points *)
  10.    numdice      = 5;           (* the number of dice in the game *)
  11.    maxplays     = 6;           (* number of plays in a game *)
  12.    diemax       = 6;           (* die values go from 1-6 *)
  13.  
  14. type
  15.    diecolor     = (red,green,black,white);  (*possible colors *)
  16.    dievalue     = 1..diemax;   (* possible values a die can have *)
  17.    dieindex     = 1..numdice;  (* index into dice array *)
  18.  
  19.    die          = record       (* structure for each die *)
  20.       color  : diecolor;       (* its color *)
  21.       value  : dievalue        (* its value *)
  22.    end;
  23.  
  24.    tabletype    = 1..scores;   (* possible ways to score *)
  25.    scoretype    = array[tabletype] of integer; (* used for scoring *)
  26.  
  27. var
  28.    dice : array[dieindex] of die;    (* the dice *)
  29.    score : array[1..maxplayers] of scoretype; (* keep track of scores *)
  30.    numplayers : integer;       (* number of players in the game *)
  31.    curgame : 1..maxplays;      (* current play number *)
  32.    ch : char;                  (* input character *)
  33.    colors : array[diecolor] of string[7]; (* will contain red,...*)
  34.    tables : array[tabletype] of string[41]; (* how scoring is done *)
  35.    j : 1..maxplayers;
  36.  
  37. (*
  38.  * print
  39.  * prints out a given players points
  40.  *)
  41.  
  42. procedure print(player:integer);
  43.  
  44. var
  45.    sum : integer;
  46.    bonus : integer;
  47.    i : tabletype;
  48.  
  49. begin
  50.    sum := 0;
  51.    for i :=1 to 6 do
  52.    begin
  53.       sum := sum + score[player][i];
  54.       writeln(tables[i],' = ',score[player][i])
  55.    end;
  56.    bonus := 0;
  57.    if sum >= 63 then
  58.       if sum <= 70 then
  59.          bonus := 35
  60.       else
  61.          if sum <= 77 then
  62.             bonus := 55
  63.          else
  64.             bonus := 75;
  65.    writeln;
  66.    writeln('Basic section totals to ',sum);
  67.    if bonus <> 0 then
  68.    begin
  69.       writeln('with bonus added of ',bonus);
  70.       writeln('Grand total for basic section ',sum+bonus)
  71.    end;
  72.    writeln;
  73.    sum := sum + bonus;
  74.    for i := 7 to scores do
  75.    begin
  76.       sum := sum + score[player][i];
  77.       writeln(tables[i],' = ',score[player][i])
  78.    end;
  79.    writeln;
  80.    writeln('Total game value = ',sum)
  81.  
  82. end;
  83.  
  84. (*
  85.  * play
  86.  * given a player, it will roll the dice,
  87.  * print out the board, keep score, and do
  88.  * anything else that needs to be done
  89.  *)
  90.  
  91. procedure play(player:integer);
  92.  
  93. var
  94.    num    : integer;           (* input number from user *)
  95.    roll   : 1..4;              (* roll we are on *)
  96.    ch     : char;              (* input character *)
  97.    i      : 1..maxplayers;     (* index for printing everyone's board *)
  98.    dienum : dieindex;          (* used in rolling the dice *)
  99.  
  100. (*
  101.  * rolldie
  102.  * will return a random number, and a random
  103.  * color for a die
  104.  *)
  105.  
  106. procedure rolldie(var dice : die);
  107.  
  108. begin
  109.    dice.value := random(diemax) + 1;
  110.    case (1 + random(3)) of
  111.       1: dice.color := red;
  112.       2: dice.color := green;
  113.       3: dice.color := black
  114.    end
  115. end;
  116.  
  117. (*
  118.  * dietotal
  119.  * returns the total of the sum of all the dice.
  120.  *)
  121.  
  122. function dietotal:integer;
  123.  
  124. var
  125.    i: dieindex;
  126.    sum : integer;
  127.  
  128. begin
  129.    sum := 0;
  130.    for i := 1 to numdice do
  131.       sum := sum + dice[i].value;
  132.    dietotal := sum
  133. end;
  134.  
  135. (*
  136.  * points
  137.  * gives out points to a player
  138.  * the way he (she) asked. for example, if the variable
  139.  * how = 8 then the player asked for 3-of-a-kind
  140.  *)
  141.  
  142. procedure points(how:tabletype);
  143.  
  144. var
  145.    i,j,k   : integer;      (* indices into dice array *)
  146.    return  : boolean;      (* used by subprocedures *)
  147.    sum     : integer;      (* point sum *)
  148.  
  149. (*
  150.  * ifany
  151.  * scores points if any correct
  152.  * die values are shown
  153.  *)
  154.  
  155. procedure ifany;
  156.  
  157. begin
  158.    sum := 0;
  159.    for i := 1 to numdice do
  160.       if dice[i].value = how then
  161.          sum := sum + how
  162. end;
  163.  
  164. (*
  165.  * pair
  166.  * sees if there are 2 different pairs,
  167.  * with the 2 component of each pair having
  168.  * the same color
  169.  *)
  170.  
  171. function pair:boolean;
  172.  
  173. var
  174.    numpairs : 0..3;
  175.  
  176. begin
  177.    numpairs := 0;
  178.    for i := 1 to numdice -1 do
  179.       for j := i+1 to numdice do
  180.          if (dice[i].value = dice[j].value) and
  181.             (dice[i].color = dice[j].color) then
  182.          begin
  183.             numpairs := numpairs + 1;
  184.             dice[i].color := white;
  185.             dice[j].color := white  (* make sure neither is reused in a test *)
  186.          end;
  187.    pair := numpairs >= 2
  188. end;
  189.  
  190. (*
  191.  * three
  192.  * returns whether on not there is a three of a kind in the dice
  193.  *)
  194.  
  195. function three:boolean;
  196.  
  197. begin
  198.    three := false;
  199.  
  200.    (*
  201.     * simply roll through all combinations of three
  202.     * and see if any are all equal
  203.     *)
  204.  
  205.    for i := 1 to (numdice -2) do
  206.       for j := i+1 to (numdice -1) do
  207.          for k := i+2 to numdice do
  208.             if (dice[i].value = dice[j].value) and
  209.                (dice[j].value = dice[k].value) then
  210.                three := true
  211. end;
  212.  
  213. (*
  214.  * straight
  215.  * returns whether or not there is a straight in the dice
  216.  *)
  217.  
  218. function straight:boolean;
  219.  
  220. var
  221.    has : set of 1..6;   (* the dice put in a set *)
  222.  
  223. begin
  224.    has := [];
  225.    for i := 1 to numdice do
  226.       has := has + [dice[i].value];
  227.    straight := (has = [1,2,3,4,5]) or (has = [2,3,4,5,6])
  228. end;
  229.  
  230. (*
  231.  * flush
  232.  * whether or not there is a flush
  233.  *)
  234.  
  235. function flush:boolean;
  236.  
  237. begin
  238.    flush := true;
  239.    for i := 1 to (numdice - 1) do
  240.       if dice[i].color <> dice[i+1].color then
  241.          flush := false
  242. end;
  243.  
  244.  
  245. (*
  246.  * fullhouse
  247.  * if there is a full house in the dice
  248.  *)
  249.  
  250. function fullhouse:boolean;
  251.  
  252.    (*
  253.     * ifpair
  254.     * if there is a pair (but not 3 or > of a kind)
  255.     *)
  256.  
  257. function ifpair:boolean;
  258.  
  259. var
  260.    tmp : array[1..diemax] of 0..numdice;  (* number of each possibility *)
  261.  
  262. begin
  263.    (*
  264.     * zero out the array
  265.     *)
  266.  
  267.    for i := 1 to diemax do
  268.       tmp[i] := 0;
  269.  
  270.    (*
  271.     * count up the number of each value
  272.     *)
  273.  
  274.    for i := 1 to numdice do
  275.       tmp[dice[i].value] := tmp[dice[i].value] + 1;
  276.  
  277.    (*
  278.     * see if any is exactly 2
  279.     *)
  280.  
  281.    for i := 1 to diemax do
  282.       return := return or (tmp[i] = 2);
  283.  
  284.    ifpair := return
  285. end;
  286.  
  287. (*
  288.  * fullhouse
  289.  *)
  290.  
  291. begin
  292.    fullhouse := three and ifpair
  293. end;
  294.  
  295. (*
  296.  * 4 of a kind
  297.  *)
  298.  
  299. function four:boolean;
  300.  
  301. var
  302.    counter : integer;
  303.    j : 1..diemax;
  304.  
  305. begin
  306.    return := false;
  307.    for j := 1 to diemax do
  308.    begin
  309.       counter := 0;
  310.       for i := 1 to numdice do
  311.          if (dice[i].value = j) then
  312.             counter := counter + 1;
  313.       if (counter = 4) then
  314.          return := true
  315.    end;
  316.    four := return
  317. end;
  318.  
  319. (*
  320.  * five
  321.  * if there is five of a kind
  322.  *)
  323.  
  324. function five:boolean;
  325.  
  326. begin
  327.    five := true;
  328.    for i := 1 to (numdice - 1) do
  329.       if dice[i].value <> dice[i+1].value then
  330.          five := false
  331. end;
  332.  
  333. (* points *)
  334.  
  335. begin
  336.    sum := dietotal;
  337.    return := false;
  338.    case how of
  339.       1,2,3,4,5,6: ifany;
  340.  
  341.       7: if not pair then sum := 0;
  342.  
  343.       8: if not three then sum := 0;
  344.  
  345.       9: if straight then sum := 30 else sum := 0;
  346.  
  347.       10: if flush then sum := 35 else sum := 0;
  348.  
  349.       11: if fullhouse then sum := sum + 15 else sum := 0;
  350.  
  351.       12: if fullhouse and flush then sum := sum + 20 else sum := 0;
  352.  
  353.       13: if four then sum := sum + 25 else sum := 0;
  354.  
  355.       14: ;
  356.  
  357.       15: if five then sum := sum + 50 else sum := 0;
  358.  
  359.    end;
  360.    score[player][how] := sum;
  361.    writeln(tables[how]);
  362.    writeln('For a total of ',sum);
  363.    writeln
  364. end;
  365.  
  366. (*
  367.  * printdice
  368.  * prints out the dice in a readable format
  369.  *)
  370.  
  371. procedure printdice;
  372.  
  373. var
  374.    i : dieindex;
  375.  
  376. begin
  377.    writeln('Your dice look like:');
  378.    for i := 1 to numdice do
  379.       writeln('Die #-',i,' ',dice[i].value,' ',colors[dice[i].color]);
  380.    writeln
  381. end;
  382.  
  383. (*
  384.  * replace
  385.  * will ask for a number (num), then will replace num dice
  386.  *)
  387.  
  388. procedure replace;
  389.  
  390. var
  391.    num    : integer;
  392.    used   : set of 1..numdice;
  393.    numrep : 1..numdice;
  394.  
  395. begin
  396.    used := [];
  397.    repeat
  398.       write('Replace how many dice? ');
  399.       readln(num)
  400.    until (num > 0) and (num <= numdice);
  401.  
  402. (*
  403.  * cycle through num times replacing one die each time
  404.  *)
  405.  
  406.    for numrep := num downto 1 do
  407.    begin
  408.       repeat
  409.          repeat
  410.             write('Replace which die? ');
  411.             readln(num)
  412.          until (num > 0) and (num <= numdice)
  413.       until not (num in used);
  414.       used := used + [num];
  415.       rolldie(dice[num])
  416.    end;
  417.    roll := roll + 1
  418. end;
  419.  
  420. (* play *)
  421.  
  422. begin
  423.    writeln('Player number ',player);
  424.    for dienum := 1 to numdice do
  425.       rolldie(dice[dienum]);
  426.    roll := 1;
  427.    while roll < 4 do
  428.    begin
  429.       repeat
  430.          writeln;
  431.          printdice;
  432.          writeln('P(rint), E(veryone), S(core), R(eplace) ');
  433.          readln(ch)
  434.       until (ch in ['P','p','E','e','S','s','R','r']);
  435.       case ch of
  436.          'P','p' : print(player);
  437.          'E','e' : for i := 1 to numplayers do
  438.                       print(i);
  439.          'S','s' : roll := 4;
  440.          'R','r' : replace
  441.       end
  442.    end;
  443.    printdice;
  444.    repeat
  445.       repeat
  446.          write('Scoring number? ');
  447.          readln(num)
  448.       until (num > 0) and (num <= scores);
  449.    until score[player][num] = 0;
  450.    points(num)
  451. end;
  452.  
  453. (*
  454.  * init
  455.  * init strings
  456.  *)
  457.  
  458. procedure init;
  459.  
  460. var
  461.    i : diecolor;
  462.    j : tabletype;
  463.    k : 1..maxplayers;
  464.  
  465. begin
  466.    for k := 1 to numplayers do
  467.       for j := 1 to scores do
  468.          score[k][j] := 0;
  469.    tables[1]  := ' 1 - Aces   1 for each Ace                ';
  470.    tables[2]  := ' 2 - Dueces 2 for each Duece              ';
  471.    tables[3]  := ' 3 - Treys  3 for each Trey               ';
  472.    tables[4]  := ' 4 - Fours  4 for each Four               ';
  473.    tables[5]  := ' 5 - Fives  5 for each Five               ';
  474.    tables[6]  := ' 6 - Sixes  6 for each Six                ';
  475.    tables[7]  := ' 7 - 2 pair same color   Total dice       ';
  476.    tables[8]  := ' 8 - 3 of a kind         Total dice       ';
  477.    tables[9]  := ' 9 - Straight            30 points        ';
  478.    tables[10] := '10 - Flush   same color  35 points        ';
  479.    tables[11] := '11 - Full house          Total dice + 15  ';
  480.    tables[12] := '12 - Full house same color Total dice + 20';
  481.    tables[13] := '13 - 4 of a kind         Total dice + 25  ';
  482.    tables[14] := '14 - Yarborough  free turn total dice     ';
  483.    tables[15] := '15 - Kismet  5 of a kind Total dice + 50  ';
  484.    colors[red] := ' red ';
  485.    colors[green] := ' green ';
  486.    colors[black] := ' black '
  487. end;
  488.  
  489. (* main program *)
  490.  
  491. begin
  492.    repeat
  493.       write('How many players? ');
  494.       readln(numplayers)
  495.    until (numplayers > 0) and (numplayers <= maxplayers);
  496.    randomize;
  497.    init;
  498.    for curgame := 1 to maxplays do
  499.       for j := 1 to numplayers do
  500.          play(j);
  501.    (*
  502.     * now that it's all done, print out the results
  503.     *)
  504.    for j := 1 to numplayers do
  505.       print(j)
  506. end.
  507.